home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xlstr.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  13KB  |  518 lines
  1. /* xlstr - xlisp string and character built-in functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* local definitions */
  9. #define fix(n)    cvfixnum((FIXTYPE)(n))
  10. #define TLEFT    1
  11. #define TRIGHT    2
  12.  
  13. /* external variables */
  14. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  15. extern LVAL true;
  16. extern char buf[];
  17.  
  18. /* external procedures */
  19. extern char *strcat();
  20.  
  21. /* forward declarations */
  22. FORWARD LVAL strcompare();
  23. FORWARD LVAL chrcompare();
  24. FORWARD LVAL changecase();
  25. FORWARD LVAL trim();
  26.  
  27. /* string comparision functions */
  28. LVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */
  29. LVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */
  30. LVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */
  31. LVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */
  32. LVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */
  33. LVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */
  34.  
  35. /* string comparison functions (not case sensitive) */
  36. LVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */
  37. LVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */
  38. LVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */
  39. LVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */
  40. LVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */
  41. LVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */
  42.  
  43. /* strcompare - compare strings */
  44. LOCAL LVAL strcompare(fcn,icase)
  45.   int fcn,icase;
  46. {
  47.     int start1,end1,start2,end2,ch1,ch2;
  48.     unsigned char *p1,*p2;
  49.     LVAL str1,str2;
  50.  
  51.     /* get the strings */
  52.     str1 = xlgastring();
  53.     str2 = xlgastring();
  54.  
  55.     /* get the substring specifiers */
  56.     getbounds(str1,k_1start,k_1end,&start1,&end1);
  57.     getbounds(str2,k_2start,k_2end,&start2,&end2);
  58.  
  59.     /* setup the string pointers */
  60.     p1 = &getstring(str1)[start1];
  61.     p2 = &getstring(str2)[start2];
  62.  
  63.     /* compare the strings */
  64.     for (; start1 < end1 && start2 < end2; ++start1,++start2) {
  65.     ch1 = *p1++;
  66.     ch2 = *p2++;
  67.     if (icase) {
  68.         if (isupper(ch1)) ch1 = tolower(ch1);
  69.         if (isupper(ch2)) ch2 = tolower(ch2);
  70.     }
  71.     if (ch1 != ch2)
  72.         switch (fcn) {
  73.         case '<':    return (ch1 < ch2 ? fix(start1) : NIL);
  74.         case 'L':    return (ch1 <= ch2 ? fix(start1) : NIL);
  75.         case '=':    return (NIL);
  76.         case '#':    return (fix(start1));
  77.         case 'G':    return (ch1 >= ch2 ? fix(start1) : NIL);
  78.         case '>':    return (ch1 > ch2 ? fix(start1) : NIL);
  79.         }
  80.     }
  81.  
  82.     /* check the termination condition */
  83.     switch (fcn) {
  84.     case '<':    return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL);
  85.     case 'L':    return (start1 >= end1 ? fix(start1) : NIL);
  86.     case '=':    return (start1 >= end1 && start2 >= end2 ? true : NIL);
  87.     case '#':    return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1));
  88.     case 'G':    return (start2 >= end2 ? fix(start1) : NIL);
  89.     case '>':    return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL);
  90.     }
  91. }
  92.  
  93. /* case conversion functions */
  94. LVAL xupcase()   { return (changecase('U',FALSE)); }
  95. LVAL xdowncase() { return (changecase('D',FALSE)); }
  96.  
  97. /* destructive case conversion functions */
  98. LVAL xnupcase()   { return (changecase('U',TRUE)); }
  99. LVAL xndowncase() { return (changecase('D',TRUE)); }
  100.  
  101. /* changecase - change case */
  102. LOCAL LVAL changecase(fcn,destructive)
  103.   int fcn,destructive;
  104. {
  105.     unsigned char *srcp,*dstp;
  106.     int start,end,len,ch,i;
  107.     LVAL src,dst;
  108.  
  109.     /* get the string */
  110.     src = xlgastring();
  111.  
  112.     /* get the substring specifiers */
  113.     getbounds(src,k_start,k_end,&start,&end);
  114.     len = getslength(src) - 1;
  115.  
  116.     /* make a destination string */
  117.     dst = (destructive ? src : newstring(len+1));
  118.  
  119.     /* setup the string pointers */
  120.     srcp = getstring(src);
  121.     dstp = getstring(dst);
  122.  
  123.     /* copy the source to the destination */
  124.     for (i = 0; i < len; ++i) {
  125.     ch = *srcp++;
  126.     if (i >= start && i < end)
  127.         switch (fcn) {
  128.         case 'U':    if (islower(ch)) ch = toupper(ch); break;
  129.         case 'D':    if (isupper(ch)) ch = tolower(ch); break;
  130.         }
  131.     *dstp++ = ch;
  132.     }
  133.     *dstp = '\0';
  134.  
  135.     /* return the new string */
  136.     return (dst);
  137. }
  138.  
  139. /* trim functions */
  140. LVAL xtrim()      { return (trim(TLEFT|TRIGHT)); }
  141. LVAL xlefttrim()  { return (trim(TLEFT)); }
  142. LVAL xrighttrim() { return (trim(TRIGHT)); }
  143.  
  144. /* trim - trim character from a string */
  145. LOCAL LVAL trim(fcn)
  146.   int fcn;
  147. {
  148.     unsigned char *leftp,*rightp,*dstp;
  149.     LVAL bag,src,dst;
  150.  
  151.     /* get the bag and the string */
  152.     bag = xlgastring();
  153.     src = xlgastring();
  154.     xllastarg();
  155.  
  156.     /* setup the string pointers */
  157.     leftp = getstring(src);
  158.     rightp = leftp + getslength(src) - 2;
  159.  
  160.     /* trim leading characters */
  161.     if (fcn & TLEFT)
  162.     while (leftp <= rightp && inbag(*leftp,bag))
  163.         ++leftp;
  164.  
  165.     /* trim character from the right */
  166.     if (fcn & TRIGHT)
  167.     while (rightp >= leftp && inbag(*rightp,bag))
  168.         --rightp;
  169.  
  170.     /* make a destination string and setup the pointer */
  171.     dst = newstring((int)(rightp-leftp+2));
  172.     dstp = getstring(dst);
  173.  
  174.     /* copy the source to the destination */
  175.     while (leftp <= rightp)
  176.     *dstp++ = *leftp++;
  177.     *dstp = '\0';
  178.  
  179.     /* return the new string */
  180.     return (dst);
  181. }
  182.  
  183. /* getbounds - get the start and end bounds of a string */
  184. LOCAL getbounds(str,skey,ekey,pstart,pend)
  185.   LVAL str,skey,ekey; int *pstart,*pend;
  186. {
  187.     LVAL arg;
  188.     int len;
  189.  
  190.     /* get the length of the string */
  191.     len = getslength(str) - 1;
  192.  
  193.     /* get the starting index */
  194.     if (xlgkfixnum(skey,&arg)) {
  195.     *pstart = (int)getfixnum(arg);
  196.     if (*pstart < 0 || *pstart > len)
  197.         xlerror("string index out of bounds",arg);
  198.     }
  199.     else
  200.     *pstart = 0;
  201.  
  202.     /* get the ending index */
  203.     if (xlgkfixnum(ekey,&arg)) {
  204.     *pend = (int)getfixnum(arg);
  205.     if (*pend < 0 || *pend > len)
  206.         xlerror("string index out of bounds",arg);
  207.     }
  208.     else
  209.     *pend = len;
  210.  
  211.     /* make sure the start is less than or equal to the end */
  212.     if (*pstart > *pend)
  213.     xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
  214. }
  215.  
  216. /* inbag - test if a character is in a bag */
  217. LOCAL int inbag(ch,bag)
  218.   int ch; LVAL bag;
  219. {
  220.     unsigned char *p;
  221.     for (p = getstring(bag); *p != '\0'; ++p)
  222.     if (*p == ch)
  223.         return (TRUE);
  224.     return (FALSE);
  225. }
  226.  
  227. /* xstrcat - concatenate a bunch of strings */
  228. LVAL xstrcat()
  229. {
  230.     LVAL *saveargv,tmp,val;
  231.     unsigned char *str;
  232.     int saveargc,len;
  233.  
  234.     /* save the argument list */
  235.     saveargv = xlargv;
  236.     saveargc = xlargc;
  237.  
  238.     /* find the length of the new string */
  239.     for (len = 0; moreargs(); ) {
  240.     tmp = xlgastring();
  241.     len += (int)getslength(tmp) - 1;
  242.     }
  243.  
  244.     /* create the result string */
  245.     val = newstring(len+1);
  246.     str = getstring(val);
  247.  
  248.     /* restore the argument list */
  249.     xlargv = saveargv;
  250.     xlargc = saveargc;
  251.     
  252.     /* combine the strings */
  253.     for (*str = '\0'; moreargs(); ) {
  254.     tmp = nextarg();
  255.     strcat(str,getstring(tmp));
  256.     }
  257.  
  258.     /* return the new string */
  259.     return (val);
  260. }
  261.  
  262. /* xsubseq - return a subsequence */
  263. LVAL xsubseq()
  264. {
  265.     unsigned char *srcp,*dstp;
  266.     int start,end,len;
  267.     LVAL src,dst;
  268.  
  269.     /* get string and starting and ending positions */
  270.     src = xlgastring();
  271.  
  272.     /* get the starting position */
  273.     dst = xlgafixnum(); start = (int)getfixnum(dst);
  274.     if (start < 0 || start > getslength(src) - 1)
  275.     xlerror("string index out of bounds",dst);
  276.  
  277.     /* get the ending position */
  278.     if (moreargs()) {
  279.     dst = xlgafixnum(); end = (int)getfixnum(dst);
  280.     if (end < 0 || end > getslength(src) - 1)
  281.         xlerror("string index out of bounds",dst);
  282.     }
  283.     else
  284.     end = getslength(src) - 1;
  285.     xllastarg();
  286.  
  287.     /* setup the source pointer */
  288.     srcp = getstring(src) + start;
  289.     len = end - start;
  290.  
  291.     /* make a destination string and setup the pointer */
  292.     dst = newstring(len+1);
  293.     dstp = getstring(dst);
  294.  
  295.     /* copy the source to the destination */
  296.     while (--len >= 0)
  297.     *dstp++ = *srcp++;
  298.     *dstp = '\0';
  299.  
  300.     /* return the substring */
  301.     return (dst);
  302. }
  303.  
  304. /* xstring - return a string consisting of a single character */
  305. LVAL xstring()
  306. {
  307.     LVAL arg;
  308.  
  309.     /* get the argument */
  310.     arg = xlgetarg();
  311.